home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / tpstuff1.arc / GRAPHICS.LIB < prev    next >
Encoding:
Text File  |  1985-04-21  |  6.5 KB  |  282 lines
  1.  
  2. CONST
  3.     { Video RAM plane color segments :  blue, red,  green }
  4.   sgment : ARRAY [0..2] OF INTEGER = ( $C000,$D000,$E000 ) ;
  5.   color_name : ARRAY [0..7] OF string[7] =
  6.              ('BLACK  ','BLUE   ','RED    ','MAGENTA','GREEN  ',
  7.                'CYAN   ','YELLOW ','WHITE  ');
  8.  
  9.   black = 0;     { Pixel colors }
  10.   blue = 1;
  11.   red = 2;
  12.   magenta = 3;
  13.   green = 4;
  14.   cyan = 5;
  15.   yellow = 6;
  16.   white = 7 ;
  17.   vcr = $D8;      { Video control register }
  18.  
  19. VAR
  20.   old_vcr : integer;
  21.   aspect : array[0..225] of integer;
  22.   current_ratio : real;
  23.  
  24. {
  25.    The following routine MUST be called before any use of the graphics
  26.    routines included in this module.  It enables the video port for
  27.    graphics output and also sets up the aspect ratio table for circle
  28.    plotting.
  29. }
  30.  
  31. PROCEDURE graphon;
  32. var
  33.    i : integer;
  34. BEGIN
  35.    ClrScr;
  36.    old_vcr := port[vcr];
  37.    port[vcr] := old_vcr and $7F;
  38.    for i := 0 to 225 do
  39.       aspect[i] := round(i * 0.4843);
  40.    current_ratio := 1.0;
  41. END;
  42.  
  43. PROCEDURE graphoff;
  44. BEGIN
  45.    port[vcr] := old_vcr;
  46.    ClrScr;
  47. END;
  48.  
  49. { Returns address of X,Y pixel location }
  50. FUNCTION byteaddr (x,y:integer) : integer;
  51. VAR
  52.   xbyte,ychar,yscan : integer;
  53. BEGIN
  54.   xbyte := x DIV 8;
  55.   ychar := y DIV 9;
  56.   yscan := y MOD 9;
  57.   byteaddr := ychar*2048 + yscan*128 + xbyte;
  58. END;
  59.  
  60. { PSET: turns on a pixel of color COLOR }
  61. PROCEDURE pset (x,y,color : integer);
  62. VAR
  63.   bit_off,location,xbit,plane : integer;
  64.   vidchr : ^byte;
  65. BEGIN
  66.   location := byteaddr (x,y);
  67.   xbit := $80 SHR (x MOD 8);
  68.   bit_off:=NOT xbit;
  69.   FOR plane := 0 TO 2 DO BEGIN
  70.      vidchr := ptr(sgment[plane],location);
  71.      if (color and (1 shl plane) > 0) then
  72.         vidchr^ := vidchr^ OR xbit
  73.      ELSE
  74.         vidchr^ := vidchr^ AND bit_off;
  75.   END;
  76. END;
  77.  
  78. { PRESET: turns off a pixel at x,y }
  79. PROCEDURE preset (x,y : integer);
  80. VAR
  81.   bit_off,location,xbit,plane : integer;
  82. BEGIN
  83.   location := byteaddr (x,y);
  84.   xbit := $80 SHR (x MOD 8);
  85.   bit_off:=NOT xbit;
  86.   FOR plane := 0 TO 2 DO
  87.      mem[sgment[plane]:location] := mem[sgment[plane]:location] AND bit_off;
  88. END;
  89.  
  90. { DRAWLINE: draws a line from pixel ix1,iy1 to pixel ix2,iy2 of COLOR }
  91. procedure drawline(ix1,iy1,ix2,iy2,color : integer);
  92. var
  93.    dev, dx, dy, x, y : integer;
  94.  
  95. procedure case1;
  96. begin
  97.    for x := (ix1 + 1) to ix2 do begin
  98.       dev := dev + dy + dy;
  99.       if dev > dx then begin
  100.          y := y + 1;
  101.          dev := dev - dx - dx
  102.       end;
  103.       pset(x,y,color);
  104.    end;
  105. end;
  106.  
  107. procedure case2;
  108. begin
  109.    for y := (iy1 + 1) to iy2 do begin
  110.       dev := dev + dx + dx;
  111.       if dev > dy then begin
  112.          x := x + 1;
  113.          dev := dev - dy - dy;
  114.       end;
  115.       pset(x,y,color);
  116.    end;
  117. end;
  118.  
  119. procedure case3;
  120. begin
  121.    for x := (ix1 + 1) to ix2 do begin
  122.       dev := dev + dy + dy;
  123.       if dev > dx then begin
  124.          y := y - 1;
  125.          dev := dev - dx - dx;
  126.       end;
  127.       pset(x,y,color);
  128.    end;
  129. end;
  130.  
  131. procedure case4;
  132. begin
  133.    for y := (iy1 - 1) downto iy2 do begin
  134.       dev := dev + dx + dx;
  135.       if dev > dy then begin
  136.          x := x + 1;
  137.          dev := dev - dy - dy;
  138.       end;
  139.       pset(x,y,color);
  140.    end;
  141. end;
  142.  
  143. procedure case5;
  144. begin
  145.    for x := (ix1 - 1) downto ix2 do begin
  146.       dev := dev + dy + dy;
  147.       if dev > dx then begin
  148.          y := y + 1;
  149.          dev := dev - dx - dx;
  150.       end;
  151.       pset(x,y,color);
  152.    end;
  153. end;
  154.  
  155. procedure case6;
  156. begin
  157.    for y := (iy1 + 1) to iy2 do begin
  158.       dev := dev + dx + dx;
  159.       if dev > dy then begin
  160.          x := x - 1;
  161.          dev := dev - dy - dy;
  162.       end;
  163.       pset(x,y,color);
  164.    end;
  165. end;
  166.  
  167. procedure case7;
  168. begin
  169.    for x := (ix1 - 1) downto ix2 do begin
  170.       dev := dev + dy + dy;
  171.       if dev > dx then begin
  172.          y := y - 1;
  173.          dev := dev - dx - dx;
  174.       end;
  175.       pset(x,y,color);
  176.    end;
  177. end;
  178.  
  179. procedure case8;
  180. begin
  181.    for y := (iy1 - 1) downto iy2 do begin
  182.       dev := dev + dx + dx;
  183.       if dev > dy then begin
  184.          x := x - 1;
  185.          dev := dev - dy - dy;
  186.       end;
  187.       pset(x,y,color);
  188.    end;
  189. end;
  190.  
  191. begin {drawline}
  192.    if ix1 = ix2 then
  193.       if iy1 < iy2 then
  194.          for y := iy1 to iy2 do
  195.             pset(ix1,y,color)
  196.       else
  197.          for y := iy1 downto iy2 do
  198.             pset(ix1,y,color)
  199.    else if iy1 = iy2 then
  200.       if ix1 < ix2 then
  201.          for x := ix1 to ix2 do
  202.             pset(x,iy1,color)
  203.       else
  204.          for x := ix1 downto ix2 do
  205.             pset(x,iy1,color)
  206.    else begin
  207.       pset(ix1,iy1,color);
  208.       dev := 0;
  209.       x := ix1; y := iy1;
  210.       dx := abs(ix2 - ix1);
  211.       dy := abs(iy2 - iy1);
  212.       if ix2 >= ix1 then
  213.          if iy2 >= iy1 then
  214.             if dx >= dy then case1 else case2
  215.          else
  216.             if dx >= dy then case3 else case4
  217.       else
  218.          if iy2 >= iy1 then
  219.             if dx >= dy then case5 else case6
  220.          else
  221.             if dx >= dy then case7 else case8;
  222.    end;
  223. end;
  224.  
  225. { DRAWBOX: draws a rectangle whose upper left corner is at x1,y1
  226.            and whose lower right corner is at x2,y2 }
  227. procedure drawbox(x1,y1,x2,y2,color : integer);
  228. begin
  229.    drawline(x1,y1,x2,y1,color);
  230.    drawline(x2,y1,x2,y2,color);
  231.    drawline(x2,y2,x1,y2,color);
  232.    drawline(x1,y2,x1,y1,color);
  233. end;
  234.  
  235. { DRAWCIRCLE: draws an elipse centered at ix,iy of radius ir (in x pixels)
  236.               of 'color'.  ratio is 1.0 for a circle...greater than 1.0
  237.               for a vertical elipse and less than 1.0 for a horizontal
  238.               elipse. }
  239. procedure drawcircle(ix,iy,ir,color : integer; ratio : real);
  240. var
  241.    x,y,dev : integer;
  242.    ta : array[0..225] of integer;
  243.    i : integer;
  244.  
  245. procedure reflect;
  246. begin
  247.    pset(ix+x,iy+aspect[y],color);
  248.    pset(ix-x,iy+aspect[y],color);
  249.    pset(ix+x,iy-aspect[y],color);
  250.    pset(ix-x,iy-aspect[y],color);
  251.    if x <> y then begin
  252.       pset(ix+y,iy+aspect[x],color);
  253.       pset(ix-y,iy+aspect[x],color);
  254.       pset(ix+y,iy-aspect[x],color);
  255.       pset(ix-y,iy-aspect[x],color);
  256.    end
  257. end;
  258.  
  259. begin {drawcircle}
  260.    if ratio <> current_ratio then begin
  261.       for i := 0 to 225 do
  262.          aspect[i] := round(i * (0.4843 * ratio));
  263.       current_ratio := ratio;
  264.    end;
  265.    x := ir;
  266.    y := 0;
  267.    dev := 0;
  268.    pset(ix+ir,iy,color);
  269.    pset(ix,iy+aspect[ir],color);
  270.    pset(ix-ir,iy,color);
  271.    pset(ix,iy-aspect[ir],color);
  272.    while y < x do begin
  273.       dev := dev + y + y + 1;
  274.       y := y + 1;
  275.       if dev > x then begin
  276.          dev := dev - x - x + 1;
  277.          x := x - 1;
  278.       end;
  279.       reflect;
  280.    end
  281. end;
  282.